home *** CD-ROM | disk | FTP | other *** search
/ PC Electronics Plus 3 / PC Electronics Plus 3.iso / subdwg / lsp / mbloque.lsp < prev    next >
Lisp/Scheme  |  1994-11-14  |  3KB  |  85 lines
  1. ;***********************************************************************
  2. ;* Comando : Mbloques
  3. ;* Se usa para generar la lista de bloques que existen en el dibujo
  4. ;* actual y que el usuario pueda buscar e insertar facilmente el bloque
  5. ;* en que desea de acuerdo al prefijo.
  6. ;* Lee la tabla de definicion de bloques y extrae todos los nombres de
  7. ;* bloques que empiecen con prefijo
  8. ;************************************************************************
  9.  
  10. ; Change log
  11. ;
  12. ; 8/11/94  C.Perigault  Agrege el sinonimo maneja-bloques
  13. ;
  14. ; 
  15. ;
  16. (defun c:maneja-bloques () (c:Mbloques))
  17. (defun c:Mbloques ( / ListaEquipos EquipoNumero continuar bloque
  18.               NombreBloque numero prefijo opcion)
  19.  
  20.  
  21.   ;**********************************************************************
  22.   ;* Funcion : (printMenu lista)
  23.   ;* Comentarios : Esta funcion se utiliza para imprimir menus de seleccion
  24.   ;* en la pantalla de texto del acad para que el usuario seleccione
  25.   ;* una alternativa. La lista debe ser de la forma  (clave descripcion)
  26.   ;* donde la clave es un numero u otro objeto y descripcion un texto
  27.   ;* (generalmente)
  28.   ;************************************************************************
  29.   (defun printMenu (lista / listaTemp numeroDeFilas numero opcion)
  30.     (textscr)
  31.     (setq opcion nil)
  32.     (setq listaTemp lista)
  33.     (while listaTemp
  34.       (setq numeroDeFilas 0)
  35.       ; mientras tengamos elementos en la listaTemp o el numero de filas
  36.       ; sea menor que 20 imprimimos el menu en la pantalla
  37.       (while (and (< numeroDeFilas 20) listaTemp)
  38.     (princ "\n[")
  39.     (setq numero (car (car listaTemp)))
  40.     (if (< numero 10) (princ " "))
  41.     (princ numero)
  42.     (princ "] ")
  43.     (princ (cadr (car listaTemp)))
  44.     (setq numeroDeFilas (+ numeroDeFilas 1))
  45.     (setq listaTemp (cdr listaTemp)))
  46.       (princ "\n")
  47.       (princ "\nIngrese el numero de su opcion o [enter] para continuar: ")
  48.       (setq opcion (getint ))
  49.       (if (assoc opcion lista)
  50.        (setq listaTemp nil)))
  51.     (graphscr)
  52.     opcion)
  53.     ;******************************************************************
  54.   (graphscr)
  55.   (setq prefijo (strcase (getstring "\nPrefijo o <enter> para todos : ") nil))
  56.  
  57.   (textscr)
  58.   ; Inicializacion de variables
  59.   (setq ListaEquipos nil)
  60.   (setq EquipoNumero  1)
  61.   (setq continuar    t  )
  62.   ; Buscamos el primer bloque de la tabla de Bloques
  63.   (setq bloque (tblnext "BLOCK" t))
  64.   ; buscamos en todos los bloques definidos, los que pertenezcan
  65.   ; a la serie prefijo
  66.   (while bloque
  67.     (setq NombreBloque (cdr (assoc 2 bloque)))
  68.     (setq bloque (tblnext "BLOCK"))
  69.     ; Son las primeras letras del nombre del bloque prefijo
  70.       (if (or  (zerop (strlen prefijo))
  71.            (equal (strcase (substr NombreBloque 1
  72.                 (strlen prefijo ) )nil) prefijo))
  73.     ; Si es asi agregamos a la lista de equipos el nombre del bloque
  74.       (progn
  75.     (setq ListaEquipos (append ListaEquipos (list (list  EquipoNumero NombreBloque))))
  76.     (setq  EquipoNumero (+ EquipoNumero 1)))))
  77.     ; si existe el equipo lo insertamos
  78.     (setq opcion (printMenu listaEquipos))
  79.     (graphscr)
  80.     (if opcion
  81.       (progn
  82.     (setvar "TEXTEVAL" 1)
  83.     (command "INSERT" (cadr (assoc opcion ListaEquipos))  pause)
  84.     (setq continuar nil)
  85.     (setvar "TEXTEVAL" 0))))